Tidy Text Notebook

By David Robinson and Julia Silge

This is my notebook that I will used to go through the tidy text notebook by Julia Silge and David Robinson.

library(tidyverse)

Warning message:
In as.POSIXlt.POSIXct(x, tz) : unknown timezone 'default/America/Detroit'

library(tidytext)
library(stringr)
library(janeaustenr)
text <- c("Because I could not stop for Death - ", 
          "He kindly stopped for me -",
          "The Carriage held but just Ourselves -",
          "and Immortality")
text

[1] "Because I could not stop for Death - " 
[2] "He kindly stopped for me -"            
[3] "The Carriage held but just Ourselves -"
[4] "and Immortality"                       

text_df <- data_frame(line = 1:4, text = text)
text_df

text_df %>% 
  unnest_tokens(word, text)  # to_lower = FALSE to keep uppercase

Working with Jane Austen Books

Using the Jane Austen dataset we can make it tidy. First we’ll use mutate to create a column from existing data. Annotate line numbers and then keep track of chapters using regex.

original_books <- austen_books() %>% 
  group_by(book) %>% 
  mutate(linenumber = row_number(),
         chapter = cumsum(str_detect(text, regex("^chapter [\\divxlc]",
                                                  ignore.case = TRUE)))) %>% 
  ungroup()
original_books

Restructure it in one-token-per-row format with the unnest_tokens() function.

tidy_books <- original_books %>% 
  unnest_tokens(word, text)
tidy_books

Removing stop words

We can remove stop words

data(stop_words)
tidy_books <- tidy_books %>% 
  anti_join(stop_words)

Joining, by = "word"

tidy_books %>% 
  count(word, sort = TRUE)

Plotting data

tidy_books %>% 
  count(word, sort = TRUE) %>% 
  filter(n > 600) %>% 
  mutate(word = reorder(word, n)) %>% 
  ggplot(aes(word, n))+
  geom_col()+
  xlab(NULL)+
  coord_flip()+
  theme_bw()

Gutenbergr

HG wells books

library(gutenbergr)
hgwells <-  gutenberg_download(c(35, 36, 5230, 159))

Determining mirror for Project Gutenberg from http://www.gutenberg.org/robot/harvest
Using mirror http://aleph.gutenberg.org

tidy_hgwells <- hgwells %>% 
  unnest_tokens(word, text) %>% 
  anti_join(stop_words)

Joining, by = "word"

tidy_hgwells %>% 
  count(word, sort = TRUE)

Most commone words in novels by Bronte sisters

bronte <-  gutenberg_download(c(1260, 768, 969, 9182, 767))
tidy_bronte <- bronte %>% 
  unnest_tokens(word, text) %>% 
  anti_join(stop_words)

Joining, by = "word"

tidy_bronte %>% 
  count(word, sort = TRUE)

Comparing Bronte and HG Wells

frequency <- bind_rows(mutate(tidy_bronte, author = "Bronte Sisters"),
                       mutate(tidy_hgwells, author = "H.G. Wells"),
                       mutate(tidy_books, author = "Jane Austen")) %>% 
  mutate(word = str_extract(word, "[a-z']+")) %>% 
  count(author, word) %>% 
  group_by(author) %>% 
  mutate(proportion = n / sum(n)) %>% 
  select(-n) %>% 
  spread(author, proportion) %>% 
  gather(author, proportion, `Bronte Sisters`:`H.G. Wells`)

Graphing the comparisons

library(scales)

Attaching package: ‘scales’

The following object is masked from ‘package:purrr’:

    discard

The following object is masked from ‘package:readr’:

    col_factor

ggplot(frequency, aes(x = proportion, y = `Jane Austen`,
                      color = abs(`Jane Austen` - proportion))) +
  geom_abline(color = "gray40", lty = 2) +
  geom_jitter(alpha = 0.1, size = 2.5, width = 0.3, height = 0.3) +
  geom_text(aes(label = word, check_overlap = TRUE, vjust = 1.5))+
  scale_x_log10(labels = percent_format()) +
  scale_y_log10(labels = percent_format()) +
  scale_color_gradient(limits = c(0,0.001),
                       low = "darkslategray4", high = "gray75") +
  facet_wrap(~author, ncol = 2) +
  theme(legend.position = "none") +
  labs(y = "Jane Austen", x = NULL)

Ignoring unknown aesthetics: check_overlap

NA

Correlation analysis

cor.test(data = frequency[frequency$author == "Bronte Sisters",],
         ~ proportion + `Jane Austen`)

    Pearson's product-moment correlation

data:  proportion and Jane Austen
t = 119.65, df = 10404, p-value < 2.2e-16
alternative hypothesis: true correlation is not equal to 0
95 percent confidence interval:
 0.7527846 0.7689620
sample estimates:
      cor 
0.7609915 

cor.test(data = frequency[frequency$author == "H.G. Wells",],
         ~ proportion + `Jane Austen`)

    Pearson's product-moment correlation

data:  proportion and Jane Austen
t = 36.441, df = 6053, p-value < 2.2e-16
alternative hypothesis: true correlation is not equal to 0
95 percent confidence interval:
 0.4032800 0.4445987
sample estimates:
      cor 
0.4241601 

Sentiments dataset

library(tidytext)
sentiments

Sentiment scores

# AFINN
get_sentiments("afinn")

# Bing
get_sentiments("bing")

# NRC
get_sentiments("nrc")

Sentiment analysis can be performed with an inner join

tidy_books <- austen_books() %>% 
  group_by(book) %>% 
  mutate(linenumber = row_number(),
         chapter = cumsum(str_detect(text, regex("^chapter [\\divxlc]",
                                                 ignore_case = TRUE)))) %>% 
  ungroup() %>% 
  unnest_tokens(word, text)
tidy_books

Get a list of words that are associated with ‘joy’ and perform an inner_join to find words that are have ‘joy’ sentiment within Jane Austen’s Emma book.

# Filter words associated with 'joy'
nrcjoy <- get_sentiments("nrc") %>% 
  filter(sentiment == "joy")
# Find words associated with joy in Emma
tidy_books %>% 
  filter(book == "Emma") %>% 
  inner_join(nrcjoy) %>% 
  count(word, sort = TRUE)

Joining, by = "word"

Count up positive or negative words that are within sections of each book. We will define an index to keep track of where we are in the narrative. The index will count up sections of 80 lines of text

janeaustensentiment <- tidy_books %>% 
  inner_join(get_sentiments("bing")) %>% 
  count(book, index = linenumber %/% 80, sentiment) %>% 
  spread(sentiment, n, fill =0) %>% 
  mutate(sentiment = positive - negative)

Joining, by = "word"

janeaustensentiment

ggplot(janeaustensentiment, aes(index, sentiment, fill = book)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~book, ncol = 2, scales = "free_x")

pride_prejudice <- tidy_books %>% 
  filter(book == "Pride & Prejudice")
pride_prejudice

afinn <- pride_prejudice %>% 
  inner_join(get_sentiments("afinn")) %>% 
  group_by(index = linenumber %/% 80) %>% 
  summarise(sentiment = sum(score)) %>% 
  mutate(method = "AFINN")

Joining, by = "word"

afinn

bing_and_nrc <- bind_rows(
  pride_prejudice %>% 
    inner_join(get_sentiments("bing")) %>% 
    mutate(method = "Bing et al."),
  pride_prejudice %>% 
    inner_join(get_sentiments("nrc") %>% 
                 filter(sentiment %in% c("positive",
                                         "negative"))) %>% 
    mutate(method = "NRC")) %>% 
    count(method, index = linenumber %/% 80, sentiment) %>% 
    spread(sentiment, n, fill = 0) %>% 
    mutate(sentiment = positive - negative)

Joining, by = "word"
Joining, by = "word"

bing_and_nrc

Comparing three sentiment lexicons using Pride and Prejudice

bind_rows(afinn,
          bing_and_nrc) %>% 
  ggplot(aes(index, sentiment, fill = method)) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~method, ncol = 1 , scales = "free_y")

get_sentiments("nrc") %>% 
  filter(sentiment %in% c("positive",
                          "negative")) %>% 
  count(sentiment)

get_sentiments("bing") %>% 
  count(sentiment)

bing_words_counts <- tidy_books %>% 
  inner_join(get_sentiments("bing")) %>% 
  count(word, sentiment, sort = TRUE) %>% 
  ungroup()

Joining, by = "word"

bing_words_counts

bing_words_counts %>% 
  group_by(sentiment) %>% 
  top_n(10) %>% 
  ungroup() %>% 
  mutate(word = reorder(word, n)) %>% 
  ggplot(aes(word, n, fill = sentiment)) +
  geom_col(show.legend = FALSE)+
  facet_wrap(~sentiment, scales = "free_y") +
  labs(y = "Contribution to sentiment",
       x = NULL,
       title = "Top 10 words by Sentiment for Pride and Prejudice") +
  coord_flip()

Selecting by n

Miss is referred to as a negative word but is not in Jane Austen’s works.

custom_stop_words <- bind_rows(data_frame(word = c("miss"),
                                          lexicon = c("custom")),
                               stop_words)
custom_stop_words

Wordclouds

library(wordcloud)

Loading required package: RColorBrewer

# https://rstudio-pubs-static.s3.amazonaws.com/104366_6b7878746c4444628eaed8894d617bba.html
ggColors <- function(n) {
  hues = seq(15, 375, length=n+1)
  hcl(h=hues, l=65, c=100)[1:n]
}
gg.cols <- ggColors(8)
tidy_books %>% 
  anti_join(stop_words) %>% 
  count(word) %>% 
  with(wordcloud(word, n, max.words = 100, random.color=TRUE, 
          colors=gg.cols))

Joining, by = "word"

library(reshape2)

Attaching package: ‘reshape2’

The following object is masked from ‘package:tidyr’:

    smiths

tidy_books %>% 
  inner_join(get_sentiments("bing")) %>% 
  count(word, sentiment, sort = TRUE) %>% 
  acast(word~sentiment, value.car = "n", fill = 0) %>% 
  comparison.cloud(colors = c("gray20", "gray80"),
                   max.words = 100)

Joining, by = "word"
Using n as value column: use value.var to override.

Looking at Units Beyond Just Words

PandP_sentences <-  data_frame(text = prideprejudice) %>% 
  unnest_tokens(sentence, text, token = "sentences")

PandP_sentences$sentence[2]

[1] "however little known the feelings or views of such a man may be on his first entering a neighbourhood, this truth is so well fixed in the minds of the surrounding families, that he is considered the rightful property of some one or other of their daughters."

Figuring out how many chapters are in a book

austen_chapters <- austen_books() %>% 
  group_by(book) %>% 
  unnest_tokens(chapter, text , token = "regex",
                pattern = "Chapter|CHAPTER [\\dIVXLC]") %>% 
  ungroup()
austen_chapters %>% 
  group_by(book) %>% 
  summarise(chapters = n())

bingnegative <- get_sentiments("bing") %>% 
  filter(sentiment == "negative")
wordcounts <- tidy_books %>% 
  group_by(book, chapter) %>% 
  summarize(words = n())
tidy_books %>% 
  semi_join(bingnegative) %>% 
  group_by(book, chapter) %>% 
  summarize(negativewords = n()) %>% 
  left_join(wordcounts, by = c("book", "chapter")) %>% 
  mutate(ratio = negativewords/words) %>% 
  filter(chapter !=0) %>% 
  top_n(1) %>% 
  ungroup()

Joining, by = "word"
Selecting by ratio

# Chapter 3

Term Frequency in Jane Austen’s Novels

book_words <- austen_books() %>% 
  unnest_tokens(word,text) %>% 
  count(book,word,sort = TRUE) %>% 
  ungroup()
total_words <- book_words %>% 
  group_by(book) %>% 
  summarize(total = sum(n))
book_words <- left_join(book_words, total_words)

Joining, by = "book"

book_words

Term frequency distribution in Jane Austen’s novels

ggplot(book_words, aes(n/total, fill = book)) +
  geom_histogram(show.legend = FALSE) +
  xlim(NA, 0.0009) +
  facet_wrap(~book, ncol = 2, scales = "free_y")

NA

Zipf’s Law

Zipf’s Law: frequency that a word appears is inversely proportional to its rank.

freq_by_rank <- book_words %>% 
  group_by(book) %>% 
  mutate(rank = row_number(),
         'term frequency' = n/total)
freq_by_rank

Graph of Zipf’s law for Jane Austen’s novels

freq_by_rank %>% 
  ggplot(aes(rank, `term frequency`, color = book)) +
  geom_line(size = 1.1, alpha = 0.8, show.legend = TRUE) +
  scale_x_log10() +
  scale_y_log10()

rank_subset <-  freq_by_rank %>% 
  filter(rank <500,
         rank >10)
lm(log10(`term frequency`) ~ log10(rank), data = rank_subset)

Call:
lm(formula = log10(`term frequency`) ~ log10(rank), data = rank_subset)

Coefficients:
(Intercept)  log10(rank)  
    -0.6226      -1.1125  

freq_by_rank %>% 
  ggplot(aes(rank, `term frequency`, color = book))+
  geom_abline(intercept = -0.62, slope = -1.1, color = "gray50", linetype = 2) +
  geom_line(size = 1.1, alpha = 0.8, show.legend = FALSE) +
  scale_x_log10() +
  scale_y_log10()

The bind_tf_idf Function

book_words <- book_words %>% 
  bind_tf_idf(word, book, n)
book_words

book_words %>% 
  select(-total) %>% 
  arrange(desc(tf_idf))

book_words %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(word = factor(word, levels = rev(unique(word)))) %>% 
  group_by(book) %>% 
  top_n(15) %>% 
  ungroup() %>% 
  ggplot(aes(word, tf_idf, fill = book)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~book, ncol = 2,scales = "free") +
  coord_flip()

Selecting by tf_idf

A corpus of Physics Text

physics <- gutenberg_download(c(37729, 14725, 13476, 5001),
                              meta_fields = "author")

physics_words <- physics %>% 
  unnest_tokens(word, text) %>% 
  count(author, word, sort = TRUE) %>% 
  ungroup()
physics_words

author_order <- c("Galilei, Galileo", "Huygens, Christiaan", "Tesla, Nikola", "Einstein, Albert")
plot_physics <- physics_words %>% 
  bind_tf_idf(word, author, n) %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(word = factor(word, levels = rev(unique(word)))) %>% 
  mutate(author = factor(author, levels = author_order))
plot_physics

plot_physics %>% 
  group_by(author) %>%
  top_n(15, tf_idf) %>% 
  ungroup() %>% 
  mutate(word = reorder(word, tf_idf)) %>% 
  ggplot(aes(word, tf_idf, fill = author)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~author, ncol = 2, scales = "free") +
  coord_flip()

NA

Isolating “eq” from Einstein’s text

physics %>% 
  filter(str_detect(text, "eq\\.")) %>% 
  select(text)

K1 was used for the coordinate system for Einstein

physics %>%
  filter(str_detect(text, "K1")) %>% 
  select(text)

NA

physics %>%
  filter(str_detect(text, "AK")) %>% 
  select(text)

mystopwords <- data_frame(word = c("eq","co","rc","ac","ak","bn",
                                   "fig", "file", "cg", "cb", "cm"))
physics_words <- anti_join(physics_words, mystopwords, by = "word")
plot_physics <- physics_words %>% 
  bind_tf_idf(word, author, n) %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(word = factor(word, levels = rev(unique(word)))) %>% 
  group_by(author) %>% 
  top_n(15, tf_idf) %>% 
  ungroup() %>% 
  mutate(author = factor(author, levels = author_order))
plot_physics

ggplot(plot_physics, aes(word, tf_idf, fill = author)) +
  geom_col(show.legend = FALSE) +
  labs( x = NULL, y = "tf-idf") +
  facet_wrap(~author, ncol = 2, scales = "free") +
  coord_flip()

Chapter 4 Relationships Between Words: N-grams and Correlations

austen_bigrams <- austen_books() %>% 
  unnest_tokens(bigram, text, token = "ngrams", n = 2)
austen_bigrams

Counting and Filtering N-grams

austen_bigrams %>% 
  count(bigram, sort = TRUE)

bigrams_separated <-  austen_bigrams %>% 
  separate(bigram, into = c("word1", "word2"), sep = " ")
  
bigrams_filtered <- bigrams_separated %>% 
  filter(!word1 %in% stop_words$word) %>% 
  filter(!word2 %in% stop_words$word)
bigram_counts <- bigrams_filtered %>% 
  count(word1, word2, sort = TRUE)
bigram_counts

bigrams_united <- bigrams_filtered %>% 
  unite(bigram, word1, word2, sep = " ")
bigrams_united

austen_books() %>% 
  unnest_tokens(trigram, text, token = "ngrams", n = 3) %>% 
  separate(trigram, into = c("word1", "word2", "word3"), sep = " ") %>% 
  filter(!word1 %in% stop_words$word,
         !word2 %in% stop_words$word,
         !word3 %in% stop_words$word) %>% 
  count(word1, word2, word3, sort = TRUE)

Analyzing Bigrams

Identifying the “streets” in each book.

bigrams_filtered %>% 
  filter(word2 == "street") %>% 
  count(book, word1, sort = TRUE)

bigram_tf_idf <- bigrams_united %>% 
  count(book, bigram) %>% 
  bind_tf_idf(bigram, book, n) %>% 
  arrange(desc(tf_idf))
bigram_tf_idf 

The 12 bigrams with the highest tf-idf from each Jane Austen novel.

bigram_tf_idf %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(bigram = factor(bigram, levels = rev(unique(bigram)))) %>% 
  group_by(book) %>% 
  top_n(12,tf_idf) %>% 
  ungroup() %>% 
  ggplot(aes(x = bigram, y = tf_idf, fill = book))+
    geom_col(show.legend = FALSE) +
    facet_wrap(~book, ncol = 2, scales = "free")+
    coord_flip()

Using Bigrams to Provide Context in Sentiment Analysis

bigrams_separated %>% 
  filter(word1 == "not") %>% 
  count(word1, word2, sort = TRUE)

AFINN <- get_sentiments("afinn") 
AFINN

not_words <- bigrams_separated %>% 
  rename(word = word2) %>% 
  filter(word1 == "not") %>% 
  inner_join(AFINN) %>% 
  count(word, score, sort = TRUE) %>% 
  ungroup()

Joining, by = "word"

    
    
not_words

NA

The 20 sords followed by “not” that had the greatest contribution to sentiment scores, in either a postivie or negative direction.

not_words %>% 
  mutate(contribution = n * score) %>% 
  arrange(desc(abs(contribution))) %>% 
  head(20) %>% 
  mutate(word = reorder(word, contribution)) %>% 
  ggplot(aes(word, n * score, fill = n * score > 0)) +
  geom_col(show.legend = FALSE) +
  xlab("Words preceded by \"not\"") +
  ylab("Sentiment score * number of occurences") +
  coord_flip()

negation_words <- c("not", "no", "never", "without")
negated_words <- bigrams_separated %>% 
  filter(word1 %in% negation_words) %>% 
  inner_join(AFINN, by = c(word2 = "word")) %>% 
  count(word1, word2, sort = TRUE) %>% 
  ungroup()
negated_words %>% 
  inner_join(not_words) %>% 
  mutate(contribution = n * score) %>% 
  arrange(desc(abs(contribution))) %>% 
  head(12) %>% 
  mutate(word = reorder(word, contribution)) %>% 
  ggplot(aes(word, n * score, fill = n * score > 0)) +
  geom_col(show.legend = FALSE) +
  xlab("Words preceded by \"not\"") +
  ylab("Sentiment score * number of occurences") +
  coord_flip() +
  facet_wrap(~word1)

Joining, by = "n"

Analyzing networks with igraph.

Create an igraph object from tidy data using the ‘graph_from_data_frame()’ function, which takes a data frame of edges with columns for “from”, “to” and edge attributes (in this case n).

library(igraph)

Attaching package: ‘igraph’

The following objects are masked from ‘package:dplyr’:

    as_data_frame, groups, union

The following objects are masked from ‘package:purrr’:

    compose, simplify

The following object is masked from ‘package:tidyr’:

    crossing

The following object is masked from ‘package:tibble’:

    as_data_frame

The following objects are masked from ‘package:stats’:

    decompose, spectrum

The following object is masked from ‘package:base’:

    union

bigram_counts

bigram_graph <- bigram_counts %>% 
  filter(n > 20) %>% 
  graph_from_data_frame()
bigram_graph

IGRAPH 48ae45c DN-- 91 77 -- 
+ attr: name (v/c), n (e/n)
+ edges from 48ae45c (vertex names):
 [1] sir     ->thomas     miss    ->crawford   captain ->wentworth 
 [4] miss    ->woodhouse  frank   ->churchill  lady    ->russell   
 [7] lady    ->bertram    sir     ->walter     miss    ->fairfax   
[10] colonel ->brandon    miss    ->bates      lady    ->catherine 
[13] sir     ->john       jane    ->fairfax    miss    ->tilney    
[16] lady    ->middleton  miss    ->bingley    thousand->pounds    
[19] miss    ->dashwood   miss    ->bennet     john    ->knightley 
[22] miss    ->morland    captain ->benwick    dear    ->miss      
+ ... omitted several edges

Commone bigrams in Pride and Prejudice, showing those that occurred more thatn 20 times and where neighter word was a stop word

library(ggraph)
set.seed(2017)
ggraph(bigram_graph, layout = "fr") +
  geom_edge_link() +
  geom_node_point() +
  geom_node_text(aes(label = name), vjust = 1, hjust = 1)

Common bigrams in Pride and Prejudice, with some polishing

set.seed(2016)
a <- grid::arrow(type = "closed", length = unit(.15, "inches"))
ggraph(bigram_graph, layout = "fr") +
  geom_edge_link(aes(edge_alpha = n), show.legend = FALSE,
                 arrow = a, end_cap = circle(.07, 'inches')) +
  geom_node_point(color = "lightblue", size = 5) +
  geom_node_text(aes(label = name), vjust = 1, hjust = 1) +
  theme_void()

Topicmodels package

library(tm)

Loading required package: NLP

Attaching package: ‘NLP’

The following object is masked from ‘package:ggplot2’:

    annotate

data("AssociatedPress", package = "topicmodels")
AssociatedPress

<<DocumentTermMatrix (documents: 2246, terms: 10473)>>
Non-/sparse entries: 302031/23220327
Sparsity           : 99%
Maximal term length: 18
Weighting          : term frequency (tf)

terms <- Terms(AssociatedPress)
head(terms)

[1] "aaron"      "abandon"    "abandoned"  "abandoning" "abbott"     "abboud"    

# library(tidyverse)
# library(tidytext)
ap_td <- tidy(AssociatedPress)
ap_td

ap_sentiments <- ap_td %>% 
  inner_join(get_sentiments("bing"), by = c( term = "word"))
ap_sentiments

# ggplot2
ap_sentiments %>% 
  count(sentiment, term, wt = count) %>% 
  ungroup() %>% 
  filter(n>= 200) %>% 
  mutate(n = ifelse(sentiment == "negative", -n, n)) %>% 
  mutate(term = reorder(term, n)) %>% 
  ggplot(aes(term, n, fill = sentiment)) +
  geom_col() +
  ylab("Contribution to sentiment") +
  coord_flip()

library(methods)
data("data_corpus_inaugural", package = "quanteda")
inaug_dfm <- quanteda::dfm(data_corpus_inaugural, verbose = FALSE)
inaug_dfm

Document-feature matrix of: 58 documents, 9,357 features (91.8% sparse).

inaug_td <- tidy(inaug_dfm)
inaug_td

inaug_tf_idf <- inaug_td %>%
  bind_tf_idf(term, document, count) %>% 
  arrange(desc(tf_idf))
inaug_tf_idf

NA

inaug_tf_idf %>% 
  filter(document %in% c("1861-Lincoln", "1933-Roosevelt", "1961-Kennedy", "2009-Obama")) %>% 
  ggplot(aes(reorder(term,tf_idf), tf_idf, fill = tf_idf)) +
  geom_col()+
  coord_flip()+
  facet_wrap(~document)

library(tidyr)
year_term_counts <- inaug_td %>% 
  extract(document, "year", "(\\d+)", convert = TRUE) %>% 
  complete(year, term, fill = list(count = 0)) %>% 
  group_by(year) %>% 
  mutate(year_total = sum(count))

year_term_counts %>% 
  filter(term %in% c("god", "america", "foreign",
                     "union", "constitution", "freedom")) %>% 
  ggplot(aes(year, count / year_total)) +
  geom_point() +
  geom_smooth() +
  facet_wrap(~term, scales = "free_y") +
  scale_y_continuous(labels = scales::percent_format()) +
  ylab("% frequency of word in inaugural address")

Casting tidy text data into a matrix

ap_td %>% 
  cast_dtm(document, term, count)

<<DocumentTermMatrix (documents: 2246, terms: 10473)>>
Non-/sparse entries: 302031/23220327
Sparsity           : 99%
Maximal term length: 18
Weighting          : term frequency (tf)

library(Matrix)

Attaching package: ‘Matrix’

The following object is masked from ‘package:tidyr’:

    expand

m <- ap_td %>% 
  cast_sparse(document, term , count)
class(m)

[1] "dgCMatrix"
attr(,"package")
[1] "Matrix"

dim(m)

[1]  2246 10473

library(janeaustenr)
austen_dtm <- austen_books() %>% 
  unnest_tokens(word, text) %>% 
  count(book, word) %>% 
  cast_dtm(book, word, n)
austen_dtm

<<DocumentTermMatrix (documents: 6, terms: 14520)>>
Non-/sparse entries: 40379/46741
Sparsity           : 54%
Maximal term length: 19
Weighting          : term frequency (tf)

Tidying corpus objects with metadata

data("acq")
acq

<<VCorpus>>
Metadata:  corpus specific: 0, document level (indexed): 0
Content:  documents: 50

acq[[1]]

<<PlainTextDocument>>
Metadata:  15
Content:  chars: 1287

acq_td <- tidy(acq)
acq_td

acq_tokens <- acq_td %>% 
  select(-places) %>% 
  unnest_tokens(word, text) %>% 
  anti_join(stop_words, by = "word")
# most common words
acq_tokens %>% 
  count(word, sort = TRUE)

acq_tokens %>% 
  count(id, word) %>% 
  bind_tf_idf(word, id, n) %>% 
  arrange(desc(tf_idf))

Example: Mining Financial Articles

library(stringr)
stock_tf_idf <- stock_tokens %>% 
  count(company, word) %>%
  filter(!str_detect(word, "\\d+")) %>% 
  bind_tf_idf(word, company, n) %>% 
  arrange(-tf_idf)
  
stock_tf_idf

stock_tf_idf %>% 
  group_by(company) %>% 
  top_n(10, tf_idf) %>% 
  arrange(desc(tf_idf)) %>% 
  ungroup(company) %>% 
  mutate(word = factor(word, levels = rev(unique(word))),
         company = as.factor(company)) %>% 
  ggplot(aes(word, tf_idf, fill = company))+
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~company, ncol = 2, scales = "free")+
  coord_flip()

Words with the largest contribution to sentiment scores in recent financial articles, according to the AFINN dictionary. The “contribution” is the product of the word and the sentiment score.

stock_tokens %>% 
  anti_join(stop_words, by = "word") %>% 
  count(word, id, sort = TRUE) %>% 
  inner_join(get_sentiments("afinn"), by = "word") %>% 
  group_by(word) %>% 
  summarize(contribution = sum(n * score)) %>% 
  top_n(12, abs(contribution)) %>% 
  mutate(word = reorder(word, contribution)) %>% 
  ggplot(aes(word, contribution)) +
  geom_col() +
  coord_flip() +
  labs(y = "Frequency of word * AFINN score")

stock_tokens %>% 
  count(word) %>% 
  inner_join(get_sentiments("loughran"), by = "word") %>% 
  group_by(sentiment) %>% 
  top_n(5, n) %>% 
  ungroup() %>%
  mutate(word = reorder(word, n)) %>% 
  ggplot(aes(word, n)) +
  geom_col() +
  coord_flip() +
  facet_wrap(~sentiment, scales = "free") +
  ylab("Frequency of this word in the recent financial articles")

NA

stock_sentiment_count <- stock_tokens %>% 
  inner_join(get_sentiments("loughran"), by = "word") %>% 
  count(sentiment, company) %>% 
  spread(sentiment, n, fill = 0)
stock_sentiment_count

stock_sentiment_count %>% 
  mutate(score = (positive - negative)/(positive + negative)) %>% 
  mutate(company = reorder(company, score)) %>% 
  ggplot(aes(company, score, fill = score > 0)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  labs(x = "Company",
       y = "Positivity score amond 20 recent news articles")

Chapter 6 Toic Modeling

Topic modeling methods od unsupervised classification of documents, similar to clustering on numeric data, which finds natural groups of items even when we’re not sure what we’re looking for.

Latent Dirichlet allocation (LDA) popular methods for fitting a topic model. It treats each document as a mixture of topics, and each topic as a mixture of words.

library(topicmodels)
data("AssociatedPress")
AssociatedPress

<<DocumentTermMatrix (documents: 2246, terms: 10473)>>
Non-/sparse entries: 302031/23220327
Sparsity           : 99%
Maximal term length: 18
Weighting          : term frequency (tf)

ap_lda <- LDA(AssociatedPress, k = 2, control = list(seed = 1234))
ap_lda

A LDA_VEM topic model with 2 topics.

library(tidytext)
ap_topics <- tidy(ap_lda, matrix = "beta")
ap_topics

Terms that are most common within each topic.

# library(ggplot2)
# library(dplyr)
ap_top_terms <- ap_topics %>% 
  group_by(topic) %>%
  top_n(10, beta) %>% 
  ungroup() %>% 
  arrange(topic, -beta)
ap_top_terms %>% 
  mutate(term = reorder(term, beta)) %>% 
  ggplot(aes(term,beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~topic, scales = "free") +
  coord_flip()

# library(tidyr)
beta_spread <- ap_topics %>% 
  mutate(topic = paste0("topic", topic)) %>% 
  spread(topic, beta) %>% 
  filter(topic1 > .001 | topic2 > .001) %>% 
  mutate(log_ratio = log2(topic2/ topic1))
beta_spread %>% 
  filter(log_ratio >10 | log_ratio < -10) %>% 
  ggplot(aes(reorder(term,log_ratio),log_ratio)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  labs(title = "Words with the greatest \n differences between two topics",
       x = "term",
       y = "Log2 ratio of beta in topic2/topic1")

Document-Topic Probabilities

ap_documents <- tidy(ap_lda, matrix = "gamma")
ap_documents

tidy(AssociatedPress) %>% 
  filter(document == 6) %>% 
  arrange(desc(count))

Example: The Great Library Heist

titles <- c("Twenty Thousand Leagues under the Sea", "The War of the Worlds",
            "Pride and Prejudice", "Great Expectations")
library(gutenbergr)
books <- gutenberg_works(title %in% titles) %>% 
  gutenberg_download(meta_fields = "title")
books

library(stringr)
# Divide into documents, each representing one chapter
reg <- regex("^chapter", ignore_case = TRUE)
by_chapter <- books %>% 
  group_by(title) %>% 
  mutate(chapter = cumsum(str_detect(text, reg))) %>% 
  ungroup() %>% 
  filter(chapter > 0) %>% 
  unite(document, title, chapter)
# Split into words
by_chapter_word <- by_chapter %>%
  unnest_tokens(word, text)
# Find document-word counts
word_counts <- by_chapter_word %>% 
  anti_join(stop_words) %>% 
  count(document, word, sort = TRUE) %>% 
  ungroup()

Joining, by = "word"

word_counts

LDA on chapters

chapters_dtm <- word_counts %>% 
  cast_dfm(document, word, n)
chapters_dtm

Document-feature matrix of: 194 documents, 18,215 features (97% sparse).

chapters_lda <- LDA(chapters_dtm, k = 4, control = list(seed = 1234))
chapters_lda

A LDA_VEM topic model with 4 topics.

chapter_topics <- tidy(chapters_lda, matrix = "beta")
chapter_topics

top_terms <- chapter_topics %>% 
  group_by(topic) %>% 
  top_n(5, beta) %>% 
  ungroup() %>% 
  arrange(topic, -beta)
top_terms

top_terms %>% 
  mutate(term = reorder(term, beta)) %>% 
  ggplot(aes(term, beta, fill - factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip()

Per-Document Classification

chapters_gamma <- tidy(chapters_lda, matrix = "gamma")
chapters_gamma

chapters_gamma <- chapters_gamma %>% 
  separate(document, c("title", "chapter"), sep = "_", convert = TRUE)
chapters_gamma

# Reorder titles in orde of topic 1, topic 2, etc. before plotting
chapters_gamma %>% 
  mutate(title = reorder(title, gamma * topic)) %>% 
  ggplot(aes(factor(topic), gamma)) +
  geom_boxplot() +
  facet_wrap(~title)

chapter_classifications <- chapters_gamma %>% 
  group_by(title, chapter) %>% 
  top_n(1, gamma) %>% 
  ungroup()
chapter_classifications

book_topics <- chapter_classifications %>% 
  count(title, topic) %>% 
  group_by(title) %>% 
  top_n(1, n) %>% 
  ungroup() %>% 
  transmute(consensus = title, topic)
chapter_classifications %>% 
  inner_join(book_topics, by = "topic") %>% 
  filter(title != consensus)

By-Word Assignments:augment

# library(broom)
# assignments <- augment(chapters_lda, data = chapters_dtm)
# 
# assignments
#   
# assignments <- assignments %>%
#   separate(document, c("title", "chapter"), sep = "_", convert = TRUE) %>%
#   inner_join(book_topics, by = c(".topic" = "topic"))
# 
# assignments
# 
# assignments %>%
#   count(title, consensus, wt = count) %>%
#   group_by(title) %>%
#   mutate(percent = n / sum(n)) %>%
#   ggplot(aes(consensus, title, fill = percent)) +
#   geom_tile() +
#   scale_fill_gradient2(high = "red", label = percent_format()) +
#   theme_minimal() +
#   theme(axis.text.x = element_text(angle = 90, hjust = 1),
#         panel.grid = element_blank()) +
#   labs(x = "Book words were assigned to",
#        y = "Book words came from",
#        fill = "% of assignments")
# 
# 
# 
# wrong_words <- assignments %>%
#   filter(title != consensus)
# 
# wrong_words
# 
# wrong_words %>%
#   count(title, consensus, term, wt = count) %>%
#   ungroup() %>%
#   arrange(desc(n))
# 
# word_counts %>%
#   filter(word == "flopson")

Alternative LDA Implementations

library(mallet)

# create a vector with one string per chapter
collapsed <- by_chapter_word %>%
  anti_join(stop_words, by = "word") %>%
  mutate(word = str_replace(word, "'", "")) %>%
  group_by(document) %>%
  summarize(text = paste(word, collapse = " "))

# create an empty file of "stopwords"
file.create(empty_file <- tempfile())
docs <- mallet.import(collapsed$document, collapsed$text, empty_file)

mallet_model <- MalletLDA(num.topics = 4)
mallet_model$loadDocuments(docs)
mallet_model$train(100)

# word-topic pairs
tidy(mallet_model)

# document-topic pairs
tidy(mallet_model, matrix = "gamma")

# column needs to be named "term" for "augment"
term_counts <- rename(word_counts, term = word)
augment(mallet_model, term_counts)

Chapter 7